home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / nrpas13.arc / COVSRT.PAS < prev    next >
Pascal/Delphi Source File  |  1991-05-01  |  1KB  |  41 lines
  1. PROCEDURE covsrt(VAR covar: glcovar; ncvm: integer; ma: integer;
  2.        lista: gllista; mfit: integer);
  3. (* Programs using routine COVSRT must define the types
  4. TYPE
  5.    glcovar = ARRAY [1..ncvm,1..ncvm] OF real;
  6.    gllista = ARRAY [1..mfit] OF integer;
  7. in the calling program. *)
  8. VAR
  9.    j,i: integer;
  10.    swap: real;
  11. BEGIN
  12.    FOR j := 1 TO ma-1 DO BEGIN
  13.       FOR i := j+1 TO ma DO BEGIN
  14.          covar[i,j] := 0.0
  15.       END
  16.    END;
  17.    FOR i := 1 TO mfit-1 DO BEGIN
  18.       FOR j := i+1 TO mfit DO BEGIN
  19.          IF (lista[j] > lista[i])  THEN BEGIN
  20.             covar[lista[j],lista[i]] := covar[i,j]
  21.          END ELSE BEGIN
  22.             covar[lista[i],lista[j]] := covar[i,j]
  23.          END
  24.       END
  25.    END;
  26.    swap := covar[1,1];
  27.    FOR j := 1 TO ma DO BEGIN
  28.       covar[1,j] := covar[j,j];
  29.       covar[j,j] := 0.0
  30.    END;
  31.    covar[lista[1],lista[1]] := swap;
  32.    FOR j := 2 TO mfit DO BEGIN
  33.       covar[lista[j],lista[j]] := covar[1,j]
  34.    END;
  35.    FOR j := 2 TO ma DO BEGIN
  36.       FOR i := 1 TO j-1 DO BEGIN
  37.          covar[i,j] := covar[j,i]
  38.       END
  39.    END
  40. END;
  41.